home *** CD-ROM | disk | FTP | other *** search
;;; -*- Mode: Lisp; Package:USER; Base:10 -*- ;;; ;;; This code was written by: ;;; ;;; Lawrence E. Freil <lef@nscf.org> ;;; National Science Center Foundation ;;; Augusta, Georgia 30909 ;;; ;;; If you modify this code, please comment your modifications ;;; clearly and inform the author of any improvements so they ;;; can be incorporated in future releases. ;;; ;;; nregex.lisp - My 4/8/92 attempt at a Lisp based regular expression ;;; parser. ;;; ;;; This regular expression parser operates by taking a ;;; regular expression and breaking it down into a list ;;; consisting of lisp expressions and flags. The list ;;; of lisp expressions is then taken in turned into a ;;; lambda expression that can be later applied to a ;;; string argument for parsing. ;;; ;;; First we create a copy of macros to help debug the beast (eval-when (:compile-toplevel :load-toplevel :execute) (defpackage "NREGEX" (:use "COMMON-LISP") (:export ;; Vars "*REGEX-DEBUG*" "*REGEX-GROUPS*" "*REGEX-GROUPINGS*" ;; Functions "REGEX-COMPILE" )) ) (in-package "NREGEX") (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *regex-debug* nil) ; Set to nil for no debugging code (defmacro info (message &rest args) (if *regex-debug* `(format *trace-output* ,message ,@args))) ;;; ;;; Declare the global variables for storing the paren index list. ;;; (defvar *regex-groups* (make-array 10)) (defvar *regex-groupings* 0) ) ;;; ;;; Declare a simple interface for testing. You probably wouldn't want ;;; to use this interface unless you were just calling this once. ;;; (defun regex (expression string) "Usage: (regex <expression> <string) This function will call regex-compile on the expression and then apply the string to the returned lambda list." (let ((findit (cond ((stringp expression) (regex-compile expression)) ((listp expression) expression))) (result nil)) (if (not (funcall (if (functionp findit) findit (eval `(function ,findit))) string)) (return-from regex nil)) (if (= *regex-groupings* 0) (return-from regex t)) (dotimes (i *regex-groupings*) (push (funcall 'subseq string (car (aref *regex-groups* i)) (cadr (aref *regex-groups* i))) result)) (reverse result))) ;;; ;;; Declare some simple macros to make the code more readable. ;;; (defvar *regex-special-chars* "?*+.()[]\\${}") (defmacro add-exp (list) "Add an item to the end of expression" `(setf expression (append expression ,list))) ;;; ;;; Now for the main regex compiler routine. ;;; (defun regex-compile (source &key (anchored nil) (case-sensitive t)) "Usage: (regex-compile <expression> [ :anchored (t/nil) ] [ :case-sensitive (t/nil) ]) This function take a regular expression (supplied as source) and compiles this into a lambda list that a string argument can then be applied to. It is also possible to compile this lambda list for better performance or to save it as a named function for later use" (info "Now entering regex-compile with \"~A\"~%" source) ;; ;; This routine works in two parts. ;; The first pass take the regular expression and produces a list of ;; operators and lisp expressions for the entire regular expression. ;; The second pass takes this list and produces the lambda expression. (let ((expression '()) ; holder for expressions (group 1) ; Current group index (group-stack nil) ; Stack of current group endings (result nil) ; holder for built expression. (fast-first nil)) ; holder for quick unanchored scan ;; ;; If the expression was an empty string then it alway ;; matches (so lets leave early) ;; (if (= (length source) 0) (return-from regex-compile '(lambda (&rest args) (declare (ignore args)) t))) ;; ;; If the first character is a caret then set the anchored ;; flags and remove if from the expression string. ;; (cond ((eql (char source 0) #\^) (setf source (subseq source 1)) (setf anchored t))) ;; ;; If the first sequence is .* then also set the anchored flags. ;; (This is purely for optimization, it will work without this). ;; (if (>= (length source) 2) (if (string= source ".*" :start1 0 :end1 2) (setf anchored t))) ;; ;; Also, If this is not an anchored search and the first character is ;; a literal, then do a quick scan to see if it is even in the string. ;; If not then we can issue a quick nil, ;; otherwise we can start the search at the matching character to skip ;; the checks of the non-matching characters anyway. ;; ;; If I really wanted to speed up this section of code it would be ;; easy to recognize the case of a fairly long multi-character literal ;; and generate a Boyer-Moore search for the entire literal. ;; ;; I generate the code to do a loop because on CMU Lisp this is about ;; twice as fast a calling position. ;; (if (and (not anchored) (not (position (char source 0) *regex-special-chars*)) (not (and (> (length source) 1) (position (char source 1) *regex-special-chars*)))) (setf fast-first `((if (not (do ((i start (+ i 1))) ((>= i length)) (if (,(if case-sensitive 'eql 'char-equal) (char string i) ,(char source 0)) (return (setf start i))))) (return-from final-return nil))))) ;; ;; Generate the very first expression to save the starting index ;; so that group 0 will be the entire string matched always ;; (add-exp '((setf (aref *regex-groups* 0) (list index nil)))) ;; ;; Loop over each character in the regular expression building the ;; expression list as we go. ;; (do ((eindex 0 (1+ eindex))) ((= eindex (length source))) (let ((current (char source eindex))) (info "Now processing character ~A index = ~A~%" current eindex) (case current ((#\.) ;; ;; Generate code for a single wild character ;; (add-exp '((if (>= index length) (return-from compare nil) (incf index))))) ((#\$) ;; ;; If this is the last character of the expression then ;; anchor the end of the expression, otherwise let it slide ;; as a standard character (even though it should be quoted). ;; (if (= eindex (1- (length source))) (add-exp '((if (not (= index length)) (return-from compare nil)))) (add-exp '((if (not (and (< index length) (eql (char string index) #\$))) (return-from compare nil) (incf index)))))) ((#\*) (add-exp '(ASTRISK))) ((#\+) (add-exp '(PLUS))) ((#\?) (add-exp '(QUESTION))) ((#\() ;; ;; Start a grouping. ;; (incf group) (push group group-stack) (add-exp `((setf (aref *regex-groups* ,(1- group)) (list index nil)))) (add-exp `(,group))) ((#\)) ;; ;; End a grouping ;; (let ((group (pop group-stack))) (add-exp `((setf (cadr (aref *regex-groups* ,(1- group))) index))) (add-exp `(,(- group))))) ((#\[) ;; ;; Start of a range operation. ;; Generate a bit-vector that has one bit per possible character ;; and then on each character or range, set the possible bits. ;; ;; If the first character is carat then invert the set. (let* ((invert (eql (char source (1+ eindex)) #\^)) (bitstring (make-array 256 :element-type 'bit :initial-element (if invert 1 0))) (set-char (if invert 0 1))) (if invert (incf eindex)) (do ((x (1+ eindex) (1+ x))) ((eql (char source x) #\]) (setf eindex x)) (info "Building range with character ~A~%" (char source x)) (cond ((and (eql (char source (1+ x)) #\-) (not (eql (char source (+ x 2)) #\]))) (if (>= (char-code (char source x)) (char-code (char source (+ 2 x)))) (error "Invalid range \"~A-~A\". Ranges must be in acending order" (char source x) (char source (+ 2 x)))) (do ((j (char-code (char source x)) (1+ j))) ((> j (char-code (char source (+ 2 x)))) (incf x 2)) (info "Setting bit for char ~A code ~A~%" (code-char j) j) (setf (sbit bitstring j) set-char))) (t (cond ((not (eql (char source x) #\])) (let ((char (char source x))) ;; ;; If the character is quoted then find out what ;; it should have been ;; (if (eql (char source x) #\\ ) (let ((length)) (multiple-value-setq (char length) (regex-quoted (subseq source x) invert)) (incf x length))) (info "Setting bit for char ~A code ~A~%" char (char-code char)) (if (not (vectorp char)) (setf (sbit bitstring (char-code (char source x))) set-char) (bit-ior bitstring char t)))))))) (add-exp `((let ((range ,bitstring)) (if (>= index length) (return-from compare nil)) (if (= 1 (sbit range (char-code (char string index)))) (incf index) (return-from compare nil))))))) ((#\\ ) ;; ;; Intreprete the next character as a special, range, octal, group or ;; just the character itself. ;; (let ((length) (value)) (multiple-value-setq (value length) (regex-quoted (subseq source (1+ eindex)) nil)) (cond ((listp value) (add-exp value)) ((characterp value) (add-exp `((if (not (and (< index length) (eql (char string index) ,value))) (return-from compare nil) (incf index))))) ((vectorp value) (add-exp `((let ((range ,value)) (if (>= index length) (return-from compare nil)) (if (= 1 (sbit range (char-code (char string index)))) (incf index) (return-from compare nil))))))) (incf eindex length))) (t ;; ;; We have a literal character. ;; Scan to see how many we have and if it is more than one ;; generate a string= verses as single eql. ;; (let* ((lit "") (term (dotimes (litindex (- (length source) eindex) nil) (let ((litchar (char source (+ eindex litindex)))) (if (position litchar *regex-special-chars*) (return litchar) (progn (info "Now adding ~A index ~A to lit~%" litchar litindex) (setf lit (concatenate 'string lit (string litchar))))))))) (if (= (length lit) 1) (add-exp `((if (not (and (< index length) (,(if case-sensitive 'eql 'char-equal) (char string index) ,current))) (return-from compare nil) (incf index)))) ;; ;; If we have a multi-character literal then we must ;; check to see if the next character (if there is one) ;; is an astrisk or a plus. If so then we must not use this ;; character in the big literal. (progn (if (or (eql term #\*) (eql term #\+)) (setf lit (subseq lit 0 (1- (length lit))))) (add-exp `((if (< length (+ index ,(length lit))) (return-from compare nil)) (if (not (,(if case-sensitive 'string= 'string-equal) string ,lit :start1 index :end1 (+ index ,(length lit)))) (return-from compare nil) (incf index ,(length lit))))))) (incf eindex (1- (length lit)))))))) ;; ;; Plug end of list to return t. If we made it this far then ;; We have matched! (add-exp '((setf (cadr (aref *regex-groups* 0)) index))) (add-exp '((return-from final-return t))) ;; ;;; (print expression) ;; ;; Now take the expression list and turn it into a lambda expression ;; replacing the special flags with lisp code. ;; For example: A BEGIN needs to be replace by an expression that ;; saves the current index, then evaluates everything till it gets to ;; the END then save the new index if it didn't fail. ;; On an ASTRISK I need to take the previous expression and wrap ;; it in a do that will evaluate the expression till an error ;; occurs and then another do that encompases the remainder of the ;; regular expression and iterates decrementing the index by one ;; of the matched expression sizes and then returns nil. After ;; the last expression insert a form that does a return t so that ;; if the entire nested sub-expression succeeds then the loop ;; is broken manually. ;; (setf result (copy-tree nil)) ;; ;; Reversing the current expression makes building up the ;; lambda list easier due to the nexting of expressions when ;; and astrisk has been encountered. (setf expression (reverse expression)) (do ((elt 0 (1+ elt))) ((>= elt (length expression))) (let ((piece (nth elt expression))) ;; ;; Now check for PLUS, if so then ditto the expression and then let the ;; ASTRISK below handle the rest. ;; (cond ((eql piece 'PLUS) (cond ((listp (nth (1+ elt) expression)) (setf result (append (list (nth (1+ elt) expression)) result))) ;; ;; duplicate the entire group ;; NOTE: This hasn't been implemented yet!! (t (format *standard-output* "GROUP repeat hasn't been implemented yet~%"))))) (cond ((listp piece) ;Just append the list (setf result (append (list piece) result))) ((eql piece 'QUESTION) ; Wrap it in a block that won't fail (cond ((listp (nth (1+ elt) expression)) (setf result (append `((progn (block compare ,(nth (1+ elt) expression)) t)) result)) (incf elt)) ;; ;; This is a QUESTION on an entire group which ;; hasn't been implemented yet!!! ;; (t (format *standard-output* "Optional groups not implemented yet~%")))) ((or (eql piece 'ASTRISK) ; Do the wild thing! (eql piece 'PLUS)) (cond ((listp (nth (1+ elt) expression)) ;; ;; This is a single character wild card so ;; do the simple form. ;; (setf result `((let ((oindex index)) (declare (fixnum oindex)) (block compare (do () (nil) ,(nth (1+ elt) expression))) (do ((start index (1- start))) ((< start oindex) nil) (declare (fixnum start)) (let ((index start)) (declare (fixnum index)) (block compare ,@result)))))) (incf elt)) (t ;; ;; This is a subgroup repeated so I must build ;; the loop using several values. ;; )) ) (t t)))) ; Just ignore everything else. ;; ;; Now wrap the result in a lambda list that can then be ;; invoked or compiled, however the user wishes. ;; (if anchored (setf result `(lambda (string &key (start 0) (end (length string))) (declare (string string) (fixnum start end) (optimize (speed 0) (compilation-speed 3))) (setf *regex-groupings* ,group) (block final-return (block compare (let ((index start) (length end)) (declare (fixnum index length)) ,@result))))) (setf result `(lambda (string &key (start 0) (end (length string))) (declare (string string) (fixnum start end) (optimize (speed 0) (compilation-speed 3))) (setf *regex-groupings* ,group) (block final-return (let ((length end)) (declare (fixnum length)) ,@fast-first (do ((marker start (1+ marker))) ((> marker end) nil) (declare (fixnum marker)) (let ((index marker)) (declare (fixnum index)) (if (block compare ,@result) (return t))))))))))) ;;; ;;; Define a function that will take a quoted character and return ;;; what the real character should be plus how much of the source ;;; string was used. If the result is a set of characters, return an ;;; array of bits indicating which characters should be set. If the ;;; expression is one of the sub-group matches return a ;;; list-expression that will provide the match. ;;; (defun regex-quoted (char-string &optional (invert nil)) "Usage: (regex-quoted <char-string> &optional invert) Returns either the quoted character or a simple bit vector of bits set for the matching values" (let ((first (char char-string 0)) (result (char char-string 0)) (used-length 1)) (cond ((eql first #\n) (setf result #\NewLine)) ((eql first #\c) (setf result #\Return)) ((eql first #\t) (setf result #\Tab)) ((eql first #\d) (setf result #*0000000000000000000000000000000000000000000000001111111111000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) ((eql first #\D) (setf result #*1111111111111111111111111111111111111111111111110000000000111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) ((eql first #\w) (setf result #*0000000000000000000000000000000000000000000000001111111111000000011111111111111111111111111000010111111111111111111111111110000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) ((eql first #\W) (setf result #*1111111111111111111111111111111111111111111111110000000000111111100000000000000000000000000111101000000000000000000000000001111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) ((eql first #\b) (setf result #*0000000001000000000000000000000011000000000010100000000000100000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) ((eql first #\B) (setf result #*1111111110111111111111111111111100111111111101011111111111011111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) ((eql first #\s) (setf result #*0000000001100000000000000000000010000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000)) ((eql first #\S) (setf result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111)) ((and (>= (char-code first) (char-code #\0)) (<= (char-code first) (char-code #\9))) (if (and (> (length char-string) 2) (and (>= (char-code (char char-string 1)) (char-code #\0)) (<= (char-code (char char-string 1)) (char-code #\9)) (>= (char-code (char char-string 2)) (char-code #\0)) (<= (char-code (char char-string 2)) (char-code #\9)))) ;; ;; It is a single character specified in octal ;; (progn (setf result (do ((x 0 (1+ x)) (return 0)) ((= x 2) return) (setf return (+ (* return 8) (- (char-code (char char-string x)) (char-code #\0)))))) (setf used-length 3)) ;; ;; We have a group number replacement. ;; (let ((group (- (char-code first) (char-code #\0)))) (setf result `((let ((nstring (subseq string (car (aref *regex-groups* ,group)) (cadr (aref *regex-groups* ,group))))) (if (< length (+ index (length nstring))) (return-from compare nil)) (if (not (string= string nstring :start1 index :end1 (+ index (length nstring)))) (return-from compare nil) (incf index (length nstring))))))))) (t (setf result first))) (if (and (vectorp result) invert) (bit-xor result #*1111111110011111111111111111111101111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111 t)) (values result used-length))) 
